home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
LIBRARY
/
SHDK_2
/
SHLNGSTR.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-05-13
|
47KB
|
1,490 lines
{$I SHDEFINE.INC}
{$I SHUNITSW.INC}
{$D-,L-}
{**********************************************************************}
{************** DO NOT MODIFY THE NEXT DIRECTIVE **************}
{**********************************************************************}
{$R-,V-}
unit ShLngStr;
{
ShLngStr
A Long String Manipulation Unit
by
Bill Madison
W. G. Madison and Associates, Ltd.
13819 Shavano Downs
P.O. Box 780956
San Antonio, TX 78278-0956
(512)492-2777
CIS 73240,342
Copyright 1991 Madison & Associates
All Rights Reserved
This file may be used and distributed only in accord-
ance with the provisions described on the title page of
the accompanying documentation file
SKYHAWK.DOC
}
interface
uses
ShErrMsg,
TpInline,
TpString,
TpMemChk;
const
MaxLongString = 65517; {Maximum length of LongString.}
type
LongStringType= record
Length, {Dynamic length}
dLength : word; {"Declared" length}
lsData : array[1..1] of char;
end;
LongString = ^LongStringType;
lsCompType = (Less, Equal, Greater);
lsDelimSetType= set of char;
CharSet = set of char;
const
lsDelimSet : lsDelimSetType = [#0..#32];
lsNotFound = 0; {Returned by Pos functions if
substring not found}
RingSize : byte = 25;
lsHaltErr : boolean = true; {Stop program execution on
non-I/O errors}
{NON-I/O ERROR CODES}
lsOK = 0;
{Last operation OK.}
lsInitError = 250;
{System initialization not performed.}
lsStringTooLong = 251;
{Declared string length > MaxLongString.}
lsAllocError = 252;
{Not enough heap space for long string.}
lsRingAllocError = 253;
{Not enough heap space for long string
allocation from ring buffer.}
lsRuntimeError : word = lsOK;
{Result of last operation.}
{========== MEMORY MANAGEMENT =============================================}
procedure lsSysInit;
{Initializes the LngStr system.}
procedure lsSysDeinit;
{Deinitializes the LngStr system, releasing the ring buffer and the
associated heap space.}
function lsInit(var A : LongString; L : word) : boolean;
{"Declares" a LongString of maximum declared length L and establishes
space for it on the heap. Returns false if L is greater than
MaxLongString or not enough heap space.}
procedure lsDispose(var A : LongString);
{-Dispose of A, releasing its heap space}
{========== GENERAL HOUSEKEEPING ==========================================}
function lsComp(A1, A2 : LongString) : lsCompType;
{-Compares A1 to A2, returning LESS, EQUAL, or GREATER}
function lsCount(A, Obj : LongString): word;
function lsCountStr(A : LongString; Obj : string) : word;
{-Returns the number of occurrences of Obj in A}
function lsCountUC(A, Obj : LongString): word;
function lsCountStrUC(A : LongString; Obj : string) : word;
{-Returns the number of occurrences of Obj in A}
{ The search is not CASE SENSITIVE.}
function lsLength(A : LongString) : word;
{-Return the length of a LongString. A must have been lsInited}
function lsPos(Obj, A : LongString) : word;
function lsPosStr(Obj : string; A : LongString) : word;
{-Return the position of Obj in A, returning lsNotFound if not found}
function lsPosSet(A : CharSet; S : LongString) : word;
{-Returns the earliest position of any member of A in S.}
function lsPosUC(Obj, A : LongString) : word;
function lsPosStrUC(Obj : string; A : LongString) : word;
{-Return the position of Obj in A, returning lsNotFound if not found.
The search is not CASE SENSITIVE.}
function lsSizeOf(A : LongString) : word;
{-Returns the total heap space required for A. A must have been lsInited}
{========== LONGSTRING TRANSFER (ASSIGNMENT) ==============================}
procedure lsTransfer(A, B : LongString);
{Transfers the contents of A into B}
{NOTE: B^ := A^ yields unpredictable results. DO NOT USE!
{========== STRING <-> LONGSTRING TYPE CONVERSION =========================}
function lsLongString2Str(A : LongString) : string;
{-Convert LongString to Turbo string, truncating if longer than 255 chars}
procedure lsStr2LongString(S : string; A : LongString);
function lsStr2LongStringF(S : string) : LongString;
{-Convert a Turbo string into a LongString}
{========== MANIPULATING LONGSTRINGS, STRINGS =============================}
procedure lsConcat(A, B, C : LongString);
function lsConcatF(A, B : LongString) : LongString;
{-Concatenate two LongString strings, returning a third}
procedure lsConcatStr2Ls(A : LongString; S : string; C : LongString);
function lsConcatStr2LsF(A : LongString; S : string) : LongString;
{-Concatenate a string to a LongString, returning a new LongString}
procedure lsConcatLs2Str(S : string; A : LongString; C : LongString);
function lsConcatLs2StrF(S : string; A : LongString) : LongString;
{-Concatenate a LongString to a string, returning a new LongString}
{========== SUBSTRINGS OF LONGSTRINGS, STRINGS ============================}
procedure lsCopy(A : LongString; Start, Len : word; B : LongString);
function lsCopyF(A : LongString; Start, Len : word) : LongString;
{-Return a long substring of A. Note Start=1 for first char in A}
procedure lsDelete(A : LongString; Start, Len : word; B : LongString);
function lsDeleteF(A : LongString; Start, Len : word) : LongString;
{-Delete Len characters of A, starting at position Start}
procedure lsInsert(A, Obj : LongString; Start : word; B : LongString);
function lsInsertF(A, Obj : LongString; Start : word) : LongString;
{-Insert LongString Obj into A at position Start returning a new LongString}
procedure lsInsertStr(A : LongString; Obj : string;
Start : word; B : LongString);
function lsInsertStrF(A : LongString; Obj : string;
Start : word) : LongString;
{-Insert string Obj into A at position Start returning a new LongString}
procedure lsGetNext(LS1, LS2 : LongString);
function lsGetNextF(LS1 : LongString) : LongString;
procedure lsGetNextStr(LS1 : LongString; var S2 : string);
function lsGetNextStrF(LS1 : LongString) : string;
{-Returns the next substring of LS1 which is delimited by a member
of lsDelimSet.)
{========== LONGSTRING TRANSFORMATIONS ====================================}
procedure lsCenter(A : LongString; Width : word; B : LongString);
function lsCenterF(A : LongString; Width : word) : LongString;
{-Return a LongString centered in a LongString of blanks with specified
width}
procedure lsCenterCh(A : LongString; Ch : Char; Width : word; B : LongString);
function lsCenterChF(A : LongString; Ch : Char; Width : word) : LongString;
{-Return a LongString centered in a LongString of Ch with specified width}
procedure lsCharStr(Ch : Char; Len : word; A : LongString);
function lsCharStrF(Ch : Char; Len : word) : LongString;
{-Return a LongString of length Len filled with Ch}
procedure lsLeftPad(A : LongString; Len : word; B : LongString);
function lsLeftPadF(A : LongString; Len : word) : LongString;
{-Left-pad the LongString in A to length Len with blanks, returning
a new LongString}
procedure lsLeftPadCh(A : LongString; Ch : Char; Len : word; B : LongString);
function lsLeftPadChF(A : LongString; Ch : Char; Len : word) : LongString;
{-Left-pad the LongString in A to length Len with Ch, returning a new
LongString}
procedure lsLocase(A, B : LongString);
function lsLocaseF(A : LongString) : LongString;
{-Lowercase the LongString in A, returning a new LongString}
procedure lsPad(A : LongString; Len : word; B : LongString);
function lsPadF(A : LongString; Len : word) : LongString;
{-Right-pad the LongString in A to length Len with blanks, returning
a new LongString}
procedure lsPadCh(A : LongString; Ch : Char; Len : word; B : LongString);
function lsPadChF(A : LongString; Ch : Char; Len : word) : LongString;
{-Right-pad the LongString in A to length Len with Ch, returning
a new LongString}
procedure lsTrim(A, B : LongString);
function lsTrimF(A : LongString) : LongString;
{-Return a LongString with leading and trailing white space removed}
procedure lsTrimLead(A, B : LongString);
function lsTrimLeadF(A : LongString): LongString;
{-Return a LongString with leading white space removed}
procedure lsTrimTrail(A, B : LongString);
function lsTrimTrailF(A : LongString) : LongString;
{-Return a LongString with trailing white space removed}
procedure lsTrimLeadSet(A : LongString; CS : CharSet; B : LongString);
function lsTrimLeadSetF(A : LongString; CS : CharSet) : LongString;
{-Returns a LongString with leading characters in CS stripped.}
procedure lsTrimTrailSet(A : LongString; CS : CharSet; B : LongString);
function lsTrimTrailSetF(A : LongString; CS : CharSet) : LongString;
{-Returns a LongString with trailing characters in CS stripped.}
procedure lsTrimSet(A : LongString; CS : CharSet; B : LongString);
function lsTrimSetF(A : LongString; CS : CharSet) : LongString;
{-Returns a LongString with characters in CS stripped.}
procedure lsUpcase(A, B : LongString);
function lsUpcaseF(A : LongString) : LongString;
{-Uppercase the LongString in A, returning a new LongString}
{========== GLOBAL PROCESSING =============================================}
procedure lsDelAll(A, Obj, B : LongString);
function lsDelAllF(A, Obj : LongString): LongString;
procedure lsDelAllStr(A : LongString; Obj : string; B : LongString);
function lsDelAllStrF(A : LongString; Obj : string) : LongString;
{-Deletes all occurrences of Obj in A}
procedure lsDelAllUC(A, Obj, B : LongString);
function lsDelAllUCF(A, Obj : LongString): LongString;
procedure lsDelAllStrUC(A : LongString; Obj : string; B : LongString);
function lsDelAllStrUCF(A : LongString; Obj : string) : LongString;
{-Deletes all occurrences of Obj in A}
{ The search is not CASE SENSITIVE.}
procedure lsRepAll(A, Obj, Obj1, B : LongString);
function lsRepAllF(A, Obj, Obj1 : LongString): LongString;
procedure lsRepAllStr(A : LongString; Obj, Obj1 : string; B : LongString);
function lsRepAllStrF(A : LongString; Obj, Obj1 : string) : LongString;
{-Replaces all occurrences of Obj in A with Obj1}
procedure lsRepAllUC(A, Obj, Obj1, B : LongString);
function lsRepAllUCF(A, Obj, Obj1 : LongString): LongString;
procedure lsRepAllStrUC(A : LongString; Obj, Obj1 : string; B : LongString);
function lsRepAllStrUCF(A : LongString; Obj, Obj1 : string) : LongString;
{-Replaces all occurrences of Obj in A with Obj1}
{ The search is not CASE SENSITIVE.}
{========== INPUT / OUTPUT ================================================}
procedure lsReadLn(var F : Text; A : LongString);
{-Read a LongString from text file}
procedure lsWriteLn(var F : Text; A : LongString);
{-Write a LongString to text file}
procedure lsIon;
{-Has the same effect with respect to lsReadLn, lsWriteLn as the $I+
compiler has with respect to normal I/O operations, except that
the reported error address is meaningless.}
procedure lsIoff;
{-Has the same effect with respect to lsReadLn, lsWriteLn as the $I-
compiler has with respect to normal I/O operations, except that
the reported error address is meaningless.}
function lsIoResult : word;
{-Returns the value of IoResult resulting from the last lsReadLn or
lsWriteLn. NOTE: You MUST use lsIoResult for checking lsReadLn,
lsWriteLn. If you call IoResult instead, you will always get a 0
return.}
implementation
const
Blank : char = #32;
MaxRingSize = 100;
RingSizeM1 = MaxRingSize - 1;
lsSysInited : boolean = false;
lsMinErrNum = 250;
lsMaxErrNum = 255;
lsIoRes : word = 0;
lsIoCheck : boolean = true;
type
lsErrorNum = lsMinErrNum..lsMaxErrNum;
const
lsError : array[lsErrorNum] of string[50] =
('ShLngStr not initialized.',
'Long String too long (65517).',
'lsInit allocation failure.',
'lsInit allocation failure on ring buffer.',
'',
'');
var
Ring : array[0..RingSizeM1] of LongString;
RingPtr : ShortInt;
procedure ChkInit;
begin
if not lsSysInited then
RunErrorMsg(lsInitError, lsError[lsInitError]);
end;
procedure lsSysInit;
begin {lsSysInit}
if lsSysInited then exit;
if RingSize > MaxRingSize then begin
WriteLn('RingSize (',RingSize,') > MaxRingSize (',MaxRingSize,')');
WriteLn('Resetting to ',MaxRingSize);
RingSize := MaxRingSize;
end;
for RingPtr := 0 to RingSizeM1 do
Ring[RingPtr] := nil;
RingPtr := -1;
lsSysInited := true;
end; {lsSysInit}
procedure lsSysDeInit;
begin {lsSysDeInit}
if not lsSysInited then exit;
for RingPtr := 0 to RingSizeM1 do begin
if Ring[RingPtr] <> nil then
FreeMemCheck(Ring[RingPtr],
Ring[RingPtr]^.dLength + (2 * SizeOf(word)));
Ring[RingPtr] := nil;
end;
RingPtr := -1;
lsSysInited := false;
end; {lsSysDeInit}
function Ptr2Str(P:pointer) : string; {For debugging only!}
begin
Ptr2Str := HexPtr(Normalized(P));
end;
function max(X, Y : word) : word;
begin
if X >= Y then
max := X
else
max := Y;
end; {max}
function min(X, Y : word) : word;
begin
if X <= Y then
min := X
else
min := Y;
end; {min}
function lsInitPrim(var A : LongString; L, Err : word) : boolean;
{"Declares" a LongString of maximum declared length L and establishes
space for it on the heap. Returns false if L is greater than
MaxLongString or not enough heap space.}
var
B1 : boolean;
begin
if L > MaxLongString then begin
lsInitPrim := false;
if lsHaltErr then
RunErrorMsg(lsStringTooLong, lsError[lsStringTooLong])
else
lsRuntimeError := lsStringTooLong;
exit;
end {if}
else begin
B1 := GetMemCheck(A, L+(2*SizeOf(word)));
if not B1 then begin
lsInitPrim := false;
if lsHaltErr then
RunErrorMsg(Err, lsError[Err])
else
lsRuntimeError := Err;
end; {if not B1}
lsInitPrim := true;
A^.dLength := L;
A^.Length := 0;
end; {else}
end; {lsInitPrim}
procedure lsDispose(var A : LongString);
{-Dispose of A, releasing its heap space}
begin
FreeMemCheck(A, A^.dLength+(2*SizeOf(word)));
A := nil;
end; {lsDispose}
function lsInit(var A : LongString; L : word) : boolean;
begin {lsInit}
lsInit := lsInitPrim(A, L, lsAllocError);
end; {lsInit}
function NextInRing(L : word) : LongString;
{-lsInits the next LongString on the ring buffer, lsDisposing of its
current contents, if any.}
begin
ChkInit;
RingPtr := (RingPtr+1) mod RingSize;
if Ring[RingPtr] <> nil then
lsDispose(Ring[RingPtr]);
if not lsInitPrim(Ring[RingPtr], L, lsRingAllocError) then begin
NextInRing := nil;
end
else
NextInRing := Ring[RingPtr];
end; {NextInRing}
procedure lsTransfer(A, B : LongString);
{Transfers the contents of A to B.
Truncates if the declared length of B is less than the length of A.}
begin
if Normalized(A) = Normalized(B) then exit;
B^.Length := min(A^.Length, B^.dLength);
move(A^.lsData, B^.lsData, B^.Length);
end; {lsTransfer}
function lsLength(A : LongString) : word;
{-Return the length of a LongString string}
begin
lsLength := A^.Length;
end; {lsLength}
function lsSizeOf(A : LongString) : word;
{-Returns the **declared** length of A + the overhead words}
begin
lsSizeOf := A^.dLength + (2*SizeOf(word));
end; {lsSizeOf}
function lsLongString2Str(A : LongString) : string;
{-Convert LongString to Turbo string, truncating if longer than 255 chars}
var
S : string;
begin
S[0] := char(min(A^.Length, 255));
move(A^.lsData, S[1], byte(S[0]));
lsLongString2Str := S;
end; {lsLongString2Str}
procedure lsStr2LongString(S : string; A : LongString);
{-Convert a Turbo string into a LongString. The LongString must have
been declared.}
begin
if A = nil then exit;
A^.Length := min(A^.dLength, byte(S[0]));
move(S[1], A^.lsData, A^.Length);
end; {lsStr2LongString}
function lsStr2LongStringF(S : string) : LongString;
{-Convert a Turbo string into a LongString}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(byte(S[0]));
lsStr2LongStringF := ThisLs;
lsStr2LongString(S, ThisLs);
end; {lsStr2LongStringF}
procedure lsCopy(A : LongString; Start, Len : word; B : LongString);
{-Return a long substring of A. Note Start=1 for first char in A}
begin
if B = nil then exit;
if (A = nil) or (Start > A^.Length) then begin
B^.Length := 0;
exit;
end;
if ((Start-1) + Len) > A^.Length then
Len := A^.Length - Start + 1;
B^.Length := min(Len, B^.dLength);
move(A^.lsData[Start], B^.lsData, Len);
end; {lsCopy}
function lsCopyF(A : LongString; Start, Len : word) : LongString;
{-Return a long substring of A. Note Start=1 for first char in A}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(Len);
lsCopyF := ThisLs;
lsCopy(A, Start, Len, ThisLs);
end; {lsCopyF}
procedure lsDelete(A : LongString; Start, Len : word; B : LongString);
{-Delete Len characters of A, starting at position Start}
begin
lsTransfer(A, B);
if Start > B^.Length then exit;
if Len > B^.Length - (Start - 1) then
Len := B^.Length - (Start - 1);
B^.Length := B^.Length - Len;
move(B^.lsData[Start+Len], B^.lsData[Start], B^.Length - (Start - 1));
end; {lsDelete}
function lsDeleteF(A : LongString; Start, Len : word) : LongString;
{-Delete Len characters of A, starting at position Start}
{-The function form returns A unchanged.}
var
ThisLs : LongString;
begin
if Start > A^.Length then begin
lsDeleteF := nil;
exit;
end;
if Len > A^.Length - (Start - 1) then
Len := A^.Length - (Start - 1);
ThisLs := NextInRing(A^.Length - Len);
ThisLs^.Length := A^.Length - Len;
move(A^.lsData[1], ThisLs^.lsData[1], Start - 1);
move(A^.lsData[Start+Len], ThisLs^.lsData[Start], A^.Length - (Start - 1));
lsDeleteF := ThisLs;
end; {lsDeleteF}
procedure lsConcat(A, B, C : LongString);
{-Concatenate two LongString strings, returning a third}
var
CpyFromA,
CpyFromB : word;
begin
if A^.Length > C^.dLength then begin
CpyFromA := C^.dLength;
CpyFromB := 0;
end
else begin
if A^.Length + B^.Length > C^.dLength then begin
CpyFromA := A^.Length;
CpyFromB := C^.dLength - CpyFromA;
end
else begin
CpyFromA := A^.Length;
CpyFromB := B^.Length;
end;
end;
C^.Length := CpyFromA + CpyFromB;
move(A^.lsData, C^.lsData, CpyFromA);
move(B^.lsData, C^.lsData[CpyFromA + 1], CpyFromB);
end; {lsConcat}
function lsConcatF(A, B : LongString) : LongString;
{-Concatenate two LongString strings, returning a third}
var
ThisLs : LongString;
CpyFromB: word;
begin
if A^.Length + B^.Length > MaxLongString then
CpyFromB := MaxLongString - A^.Length
else
CpyFromB := B^.Length;
ThisLs := NextInRing(A^.Length + CpyFromB);
lsConcatF := ThisLs;
lsConcat(A, B, ThisLs);
end; {lsConcatF}
procedure lsConcatStr2Ls(A : LongString; S : string; C : LongString);
{-Concatenate a string to a LongString, returning a new LongString}
var
LS : LongString;
begin
if not lsInit(LS, A^.Length + byte(S[0])) then exit;
lsStr2LongString(S, LS);
lsConcat(A, LS, C);
lsDispose(LS);
end; {lsConcatStr2Ls}
function lsConcatStr2LsF(A : LongString; S : string) : LongString;
{-Concatenate a string to a LongString, returning a new LongString}
var
LS : LongString;
begin
if not lsInit(LS, A^.Length + byte(S[0])) then exit;
lsStr2LongString(S, LS);
lsConcatStr2LsF := lsConcatF(A, LS);
lsDispose(LS);
end; {lsConcatStr2LsF}
procedure lsConcatLs2Str(S : string; A : LongString; C : LongString);
{-Concatenate a LongString to a string, returning a new LongString}
var
LS : LongString;
begin
if not lsInit(LS, A^.Length + byte(S[0])) then exit;
lsStr2LongString(S, LS);
lsConcat(LS, A, C);
lsDispose(LS);
end; {lsConcatLs2Str}
function lsConcatLs2StrF(S : string; A : LongString) : LongString;
{-Concatenate a LongString to a string, returning a new LongString}
var
LS : LongString;
begin
if not lsInit(LS, A^.Length + byte(S[0])) then exit;
lsStr2LongString(S, LS);
lsConcatLs2StrF := lsConcatF(LS, A);
lsDispose(LS);
end; {lsConcatLs2StrF}
procedure lsInsert(A, Obj : LongString; Start : word; B : LongString);
{-Insert LongString Obj into A at position Start returning a new LongString}
var
FrontOfA,
RestOfA,
CpyFromO : word;
begin
FrontOfA := min(Start-1, B^.dLength);
if (B^.dLength - FrontOfA) > Obj^.Length then
CpyFromO := Obj^.Length
else
CpyFromO := B^.dLength - FrontOfA;
if (B^.dLength - (FrontOfA + CpyFromO)) > (A^.Length - FrontOfA) then
RestOfA := A^.Length - FrontOfA
else
RestOfA := B^.dLength - (FrontOfA + CpyFromO);
B^.Length := FrontOfA + CpyFromO + RestOfA;
move(A^.lsData, B^.lsData, FrontOfA);
move(A^.lsData[Start], B^.lsData[FrontOfA + CpyFromO + 1], RestOfA);
move(Obj^.lsData, B^.lsData[Start], CpyFromO);
end; {lsInsert}
function lsInsertF(A, Obj : LongString; Start : word) : LongString;
{-Insert LongString Obj into A at position Start returning a new LongString}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(A^.Length + Obj^.Length);
lsInsertF := ThisLs;
lsInsert(A, Obj, Start, ThisLs);
end; {lsInsertF}
procedure lsInsertStr(A : LongString; Obj : string;
Start : word; B : LongString);
{-Insert string Obj into A at position Start returning a new LongString}
var
LS : LongString;
begin
if not lsInit(LS, byte(Obj[0])) then exit;
lsStr2LongString(Obj, LS);
lsInsert(A, LS, Start, B);
lsDispose(LS);
end; {lsInsertStr}
function lsInsertStrF(A : LongString; Obj : string;
Start : word) : LongString;
{-Insert string Obj into A at position Start returning a new LongString}
var
LS : LongString;
begin
if not lsInit(LS, byte(Obj[0])) then exit;
lsStr2LongString(Obj, LS);
lsInsertStrF := lsInsertF(A, LS, Start);
lsDispose(LS);
end; {lsInsertStrF}
procedure lsUpcase(A, B : LongString);
{-Uppercase the LongString in A, returning B}
var
W1 : word;
begin
lsTransfer(A, B);
for W1 := 1 to B^.Length do
B^.lsData[W1] := Upcase(B^.lsData[W1]);
end; {lsUpcase}
function lsUpcaseF(A : LongString) : LongString;
{-Uppercase the LongString in A, returning B}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(A^.Length);
lsUpcase(A, ThisLs);
lsUpcaseF := ThisLs;
end; {lsUpcaseF}
procedure lsLocase(A, B : LongString);
{-Lowercase the LongString in A, returning B}
var
W1 : word;
begin
lsTransfer(A, B);
for W1 := 1 to B^.Length do
B^.lsData[W1] := Locase(B^.lsData[W1]);
end; {lsLocase}
function lsLocaseF(A : LongString) : LongString;
{-Lowercase the LongString in A, returning B}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(A^.Length);
lsLocase(A, ThisLs);
lsLocaseF := ThisLs;
end; {lsLocaseF}
function lsComp(A1, A2 : LongString) : lsCompType;
{-Compares A1 to A2, returning LESS, EQUAL, or GREATER}
var
W1,
Search : word;
LgthA1A2: lsCompType;
begin
if A1^.Length = A2^.Length then
LgthA1A2 := Equal
else
if A1^.Length < A2^.Length then
LgthA1A2 := Less
else
LgthA1A2 := Greater;
Search := min(A1^.Length, A2^.Length);
W1 := 1;
while (W1 < Search) and (A1^.lsData[W1] = A2^.lsData[W1]) do
inc(W1);
if A1^.lsData[W1] = A2^.lsData[W1] then begin
lsComp := LgthA1A2;
exit;
end;
if A1^.lsData[W1] < A2^.lsData[W1] then begin
lsComp := Less;
exit;
end;
if A1^.lsData[W1] > A2^.lsData[W1] then begin
lsComp := Greater;
end;
end; {lsComp}
function lsPosStr(Obj : string; A : LongString) : word;
{-Return the position of the string Obj in A, returning lsNotFound if
not found}
begin
lsPosStr := succ(Search(A^.lsData, A^.Length, Obj[1], byte(Obj[0])));
end; {lsPosStr}
function lsPos(Obj, A : LongString) : word;
{-Return the position of Obj in A, returning lsNotFound if not found}
begin
lsPos := succ(Search(A^.lsData, A^.Length, Obj^.lsData, Obj^.Length));
end; {lsPos}
function lsPosSet(A : CharSet; S : LongString) : word;
var
W1 : word;
begin
W1 := 1;
while (not (S^.lsData[W1] in A)) and (W1 < lsLength(S)) do
inc(W1);
if S^.lsData[W1] in A then
lsPosSet := W1
else
lsPosSet := 0;
end; {lsPosSet}
function lsPosStrUC(Obj : string; A : LongString) : word;
{-Return the position of the string Obj in A, returning lsNotFound if
not found. The search is not case sensitive.}
begin
lsPosStrUC := succ(SearchUC(A^.lsData, A^.Length, Obj[1], byte(Obj[0])));
end; {lsPosStrUC}
function lsPosUC(Obj, A : LongString) : word;
{-Return the position of Obj in A, returning lsNotFound if not found.
The search is not case sensitive.}
begin
lsPosUC := succ(SearchUC(A^.lsData, A^.Length, Obj^.lsData, Obj^.Length));
end; {lsPosUC}
function CountPrim(A, Obj : LongString;
CaseSens {true if case sensitive} : boolean) : word;
var
Next,
Now,
Count : word;
begin
Next := 1;
Now := 1;
Count := 0;
repeat
if CaseSens then
Now := succ(Search(A^.lsData[Next], A^.Length-Next+1,
Obj^.lsData, Obj^.Length))
else
Now := succ(SearchUC(A^.lsData[Next], A^.Length-Next+1,
Obj^.lsData, Obj^.Length));
if Now <> 0 then begin
Next := Next + Now + Obj^.Length - 1;
inc(Count);
end;
until Now = 0;
CountPrim := Count;
end; {CountPrim}
{-Returns the number of occurrences of Obj in A}
function lsCount(A, Obj : LongString): word;
begin
lsCount := CountPrim(A, Obj, true);
end; {lsCount}
function lsCountStr(A : LongString; Obj : string) : word;
var
LS : LongString;
begin
if not lsInit(LS, byte(Obj[0])) then exit;
lsStr2LongString(Obj, LS);
lsCountStr := lsCount(A, LS);
lsDispose(LS);
end; {lsCountStr}
{-Returns the number of occurrences of Obj in A}
{ The search is not CASE SENSITIVE.}
function lsCountUC(A, Obj : LongString): word;
begin
lsCountUC := CountPrim(A, Obj, false);
end; {lsCountUC}
function lsCountStrUC(A : LongString; Obj : string) : word;
var
LS : LongString;
begin
if not lsInit(LS, byte(Obj[0])) then exit;
lsStr2LongString(Obj, LS);
lsCountStrUC := lsCountUC(A, LS);
lsDispose(LS);
end; {lsCountStrUC}
procedure RepDelPrim(In0, Obj, Obj1, Out : LongString;
RepOrDel, {true if to replace}
CaseSens {true if case sensitive} : boolean);
var
In1,
Scr : LongString;
W1 : word;
function GetPos : word;
begin
if CaseSens then
GetPos := lsPos(Obj, In1)
else
GetPos := lsPosUC(Obj, In1);
end; {GetPos}
begin
if not lsInit(In1, In0^.Length) then exit;
lsTransfer(In0, In1);
W1 := GetPos;
if W1 = lsNotFound then begin
lsTransfer(In1, Out);
lsDispose(In1);
exit;
end;
if not lsInit(Scr, In1^.Length) then exit;
Out^.Length := 0;
while W1 <> lsNotFound do begin
lsCopy(In1, 1, W1-1, Scr);
lsConcat(Out, Scr, Out);
if RepOrDel then
lsConcat(Out, Obj1, Out);
lsDelete(In1, 1, W1 + Obj^.Length - 1, In1);
W1 := GetPos;
end; {while}
lsConcat(Out, In1, Out);
lsDispose(In1);
lsDispose(Scr);
end; {RepDelPrim}
{-Deletes all occurrences of Obj in A}
procedure lsDelAll(A, Obj, B : LongString);
begin
RepDelPrim(A, Obj, nil, B, false, true);
end; {lsDelAll}
function lsDelAllF(A, Obj : LongString): LongString;
var
LS : LongString;
begin
LS := NextInRing(A^.Length - (lsCount(A, Obj) * Obj^.Length));
lsDelAll(A, Obj, LS);
lsDelAllF := LS;
end; {lsDelAllF}
procedure lsDelAllStr(A : LongString; Obj : string; B : LongString);
var
LS : LongString;
begin
if not lsInit(LS, A^.Length - (lsCountStr(A, Obj) * byte(Obj[0]))) then
exit;
lsStr2LongString(Obj, LS);
lsDelAll(A, LS, B);
lsDispose(LS);
end; {lsDelAllStr}
function lsDelAllStrF(A : LongString; Obj : string) : LongString;
var
LS : LongString;
begin
if not lsInit(LS, A^.Length - (lsCountStr(A, Obj) * byte(Obj[0]))) then
exit;
lsStr2LongString(Obj, LS);
lsDelAllStrF := lsDelAllF(A, LS);
lsDispose(LS);
end; {lsDelAllStrF}
{-Deletes all occurrences of Obj in A}
{ The search is not CASE SENSITIVE.}
procedure lsDelAllUC(A, Obj, B : LongString);
begin
RepDelPrim(A, Obj, nil, B, false, false);
end; {lsDelAllUC}
function lsDelAllUCF(A, Obj : LongString): LongString;
var
LS : LongString;
begin
LS := NextInRing(A^.Length - (lsCount(A, Obj) * Obj^.Length));
lsDelAllUC(A, Obj, LS);
lsDelAllUCF := LS;
end; {lsDelAllUCF}
procedure lsDelAllStrUC(A : LongString; Obj : string; B : LongString);
var
LS : LongString;
begin
if not lsInit(LS, A^.Length - (lsCountStrUC(A, Obj) * byte(Obj[0]))) then
exit;
lsStr2LongString(Obj, LS);
lsDelAllUC(A, LS, B);
lsDispose(LS);
end; {lsDelAllStrUC}
function lsDelAllStrUCF(A : LongString; Obj : string) : LongString;
var
LS : LongString;
begin
if not lsInit(LS, A^.Length - (lsCountStr(A, Obj) * byte(Obj[0]))) then
exit;
lsStr2LongString(Obj, LS);
lsDelAllStrUCF := lsDelAllUCF(A, LS);
lsDispose(LS);
end; {lsDelAllStrUCF}
{-Replaces all occurrences of Obj in A with Obj1}
procedure lsRepAll(A, Obj, Obj1, B : LongString);
begin
RepDelPrim(A, Obj, Obj1, B, true, true);
end; {lsRepAll}
function lsRepAllF(A, Obj, Obj1 : LongString): LongString;
var
LS : LongString;
begin
LS := NextInRing(A^.Length +
(lsCount(A, Obj) * (Obj1^.Length - Obj^.Length)));
lsRepAll(A, Obj, Obj1, LS);
lsRepAllF := LS;
end; {lsRepAllF}
procedure lsRepAllStr(A : LongString; Obj, Obj1 : string; B : LongString);
var
LS0,
LS1 : LongString;
begin
if not lsInit(LS0, byte(Obj[0])) then exit;
lsStr2LongString(Obj, LS0);
if not lsInit(LS1, byte(Obj1[0])) then exit;
lsStr2LongString(Obj1, LS1);
lsRepAll(A, LS0, LS1, B);
lsDispose(LS0);
lsDispose(LS1);
end; {lsRepAllStr}
function lsRepAllStrF(A : LongString; Obj, Obj1 : string) : LongString;
var
LS0,
LS1 : LongString;
begin
if not lsInit(LS0, byte(Obj[0])) then exit;
lsStr2LongString(Obj, LS0);
if not lsInit(LS1, byte(Obj1[0])) then exit;
lsStr2LongString(Obj1, LS1);
lsRepAllStrF := lsRepAllF(A, LS0, LS1);
lsDispose(LS0);
lsDispose(LS1);
end; {lsRepAllStrF}
{-Replaces all occurrences of Obj in A with Obj1}
{ The search is not CASE SENSITIVE.}
procedure lsRepAllUC(A, Obj, Obj1, B : LongString);
begin
RepDelPrim(A, Obj, Obj1, B, true, false);
end; {lsRepAllUC}
function lsRepAllUCF(A, Obj, Obj1 : LongString): LongString;
var
LS : LongString;
begin
LS := NextInRing(A^.Length +
(lsCountUC(A, Obj) * (Obj1^.Length - Obj^.Length)));
lsRepAllUC(A, Obj, Obj1, LS);
lsRepAllUCF := LS;
end; {lsRepAllUCF}
procedure lsRepAllStrUC(A : LongString; Obj, Obj1 : string; B : LongString);
var
LS0,
LS1 : LongString;
begin
if not lsInit(LS0, byte(Obj[0])) then exit;
lsStr2LongString(Obj, LS0);
if not lsInit(LS1, byte(Obj1[0])) then exit;
lsStr2LongString(Obj1, LS1);
lsRepAllUC(A, LS0, LS1, B);
lsDispose(LS0);
lsDispose(LS1);
end; {lsRepAllStrUC}
function lsRepAllStrUCF(A : LongString; Obj, Obj1 : string) : LongString;
var
LS0,
LS1 : LongString;
begin
if not lsInit(LS0, byte(Obj[0])) then exit;
lsStr2LongString(Obj, LS0);
if not lsInit(LS1, byte(Obj1[0])) then exit;
lsStr2LongString(Obj1, LS1);
lsRepAllStrUCF := lsRepAllUCF(A, LS0, LS1);
lsDispose(LS0);
lsDispose(LS1);
end; {lsRepAllStrUCF}
procedure lsGetNextPrim(LS1, LS2 : LongString; Delims : lsDelimSetType);
var
W1 : word;
begin
if lsLength(LS1) = 0 then begin
LS2^.Length := 0;
exit;
end;
W1 := 1;
while (LS1^.lsData[W1] in Delims) and (W1 <= lsLength(LS1)) do
inc(W1);
dec(W1);
lsDelete(LS1, 1, W1, LS1);
if lsLength(LS1) = 0 then
LS2^.Length := 0
else begin
W1 := 1;
while (not (LS1^.lsData[W1] in Delims)) and (W1 <= lsLength(LS1)) do
inc(W1);
dec(W1);
if W1 <> 0 then begin
lsCopy(LS1, 1, W1, LS2);
lsDelete(LS1, 1, W1, LS1);
end
else begin
lsTransfer(LS1, LS2);
LS1^.Length := 0;
end;
end;
end; {lsGetNextPrim}
procedure lsGetNext(LS1, LS2 : LongString);
begin
lsGetNextPrim(LS1, LS2, lsDelimSet);
end;
function lsGetNextF(LS1 : LongString) : LongString;
var
Scr,
ThisLs : LongString;
begin
if not lsInit(Scr, LS1^.Length) then exit;
lsGetNextPrim(LS1, Scr, lsDelimSet);
ThisLs := NextInRing(Scr^.Length);
lsTransfer(Scr, ThisLs);
lsDispose(Scr);
lsGetNextF := ThisLs;
end; {lsGetNextF}
procedure lsGetNextStr(LS1 : LongString; var S2 : string);
var
LS2 : LongString;
begin
if not lsInit(LS2, LS1^.Length) then exit;
lsGetNextPrim(LS1, LS2, lsDelimSet);
S2 := lsLongString2Str(LS2);
lsDispose(LS2);
end; {lsGetNextStr}
function lsGetNextStrF(LS1 : LongString) : string;
var
LS2 : LongString;
begin
if not lsInit(LS2, LS1^.Length) then exit;
lsGetNextPrim(LS1, LS2, lsDelimSet);
lsGetNextStrF := lsLongString2Str(LS2);
lsDispose(LS2);
end; {lsGetNextStrF}
procedure lsCharStr(Ch : Char; Len : word; A : LongString);
{-Return a LongString of length Len filled with Ch}
begin
A^.Length := min(Len, A^.dLength);
FillChar(A^.lsData, A^.Length, Ch);
end; {lsCharStr}
function lsCharStrF(Ch : Char; Len : word) : LongString;
{-Return a LongString of length Len filled with Ch}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(Len);
lsCharStr(Ch, Len, ThisLs);
lsCharStrF := ThisLs;
end; {lsCharStrF}
procedure lsPadCh(A : LongString; Ch : Char; Len : word; B : LongString);
{-Right-pad the LongString in A to length Len with Ch, returning B}
var
CpyFromA,
LenOfCh : word;
begin
Len := min(B^.dLength, Len);
CpyFromA := min(A^.Length, Len);
if Len > CpyFromA then
LenOfCh := Len - CpyFromA
else
LenOfCh := 0;
B^.Length := Len;
move(A^.lsData, B^.lsData, CpyFromA);
FillChar(B^.lsData[CpyFromA+1], LenOfCh, Ch);
end; {lsPadCh}
function lsPadChF(A : LongString; Ch : Char; Len : word) : LongString;
{-Right-pad the LongString in A to length Len with Ch, returning B}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(Len);
lsPadCh(A, Ch, Len, ThisLs);
lsPadChF := ThisLs;
end; {lsPadChF}
procedure lsPad(A : LongString; Len : word; B : LongString);
{-Right-pad the LongString in A to length Len with blanks, returning B}
begin
lsPadCh(A, Blank, Len, B);
end; {lsPad}
function lsPadF(A : LongString; Len : word) : LongString;
{-Right-pad the LongString in A to length Len with blanks, returning B}
begin
lsPadF := lsPadChF(A, Blank, Len);
end; {lsPad}
procedure lsLeftPadCh(A : LongString; Ch : Char; Len : word; B : LongString);
{-Left-pad the LongString in A to length Len with Ch, returning B}
var
CpyFromA,
LenOfCh : word;
ThisLs : LongString;
begin
Len := min(B^.dLength, Len);
ThisLs := NextInRing(Len);
CpyFromA := min(A^.Length, Len);
if Len > CpyFromA then
LenOfCh := Len - CpyFromA
else
LenOfCh := 0;
ThisLs^.Length := Len;
move(A^.lsData, ThisLs^.lsData[LenOfCh+1], CpyFromA);
FillChar(ThisLs^.lsData, LenOfCh, Ch);
lsTransfer(ThisLs, B);
end; {lsLeftPadCh}
function lsLeftPadChF(A : LongString; Ch : Char; Len : word) : LongString;
{-Left-pad the LongString in A to length Len with Ch, returning B}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(Len);
lsLeftPadCh(A, Ch, Len, ThisLs);
lsLeftPadChF := ThisLs;
end; {lsLeftPadChF}
procedure lsLeftPad(A : LongString; Len : word; B : LongString);
{-Left-pad the LongString in A to length Len with blanks, returning B}
begin
lsLeftPadCh(A, Blank, Len, B);
end; {lsLeftPad}
function lsLeftPadF(A : LongString; Len : word) : LongString;
{-Left-pad the LongString in A to length Len with blanks, returning B}
begin
lsLeftPadF := lsLeftPadChF(A, Blank, Len);
end; {lsLeftPad}
procedure lsTrimLeadSet(A : LongString; CS : CharSet; B : LongString);
{-Returns a LongString with leading characters in CS stripped.}
var
W1 : word;
begin
lsTransfer(A, B);
W1 := lsPosSet([#0..#255] - CS, B);
if W1 <> 0 then
lsDelete(B, 1, pred(W1), B);
end; {lsTrimLeadSet}
function lsTrimLeadSetF(A : LongString; CS : CharSet) : LongString;
{-Returns a LongString with leading characters in CS stripped.}
var
ThisLS : LongString;
begin {lsTrimLeadSetF}
ThisLs := NextInRing(A^.Length);
lsTrimLeadSet(A, CS, ThisLs);
lsTrimLeadSetF := ThisLs;
end; {lsTrimLeadSetF}
procedure lsTrimTrailSet(A : LongString; CS : CharSet; B : LongString);
{-Returns a LongString with trailing characters in CS stripped.}
var
W1 : word;
begin
lsTransfer(A, B);
W1 := B^.Length;
while (W1 >= 1) and (B^.lsData[W1] in CS) do begin
dec(W1);
dec(B^.Length);
end;
end; {lsTrimTrailSet}
function lsTrimTrailSetF(A : LongString; CS : CharSet) : LongString;
{-Returns a LongString with trailing characters in CS stripped.}
var
ThisLs : LongString;
begin {lsTrimTrailSetF}
ThisLs := NextInRing(A^.Length);
lsTrimTrailSet(A, CS, ThisLs);
lsTrimTrailSetF := ThisLs;
end; {lsTrimTrailSetF}
procedure lsTrimSet(A : LongString; CS : CharSet; B : LongString);
{-Returns a LongString with characters in CS stripped.}
var
ThisLs : LongString;
begin
if not lsInit(ThisLs, A^.Length) then exit;
lsTransfer(A, ThisLs);
lsTrimLeadSet(lsTrimTrailSetF(ThisLs, CS), CS, B);
lsDispose(ThisLs);
end; {lsTrimSet}
function lsTrimSetF(A : LongString; CS : CharSet) : LongString;
{-Returns a LongString with characters in CS stripped.}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(A^.Length);
lsTrimSet(A, CS, ThisLs);
lsTrimSetF := ThisLs;
end; {lsTrimSetF}
procedure lsTrimLead(A, B : LongString);
{-Return a LongString with leading white space removed}
var
W1 : word;
begin
lsTransfer(A, B);
W1 := 1;
while (W1 <= B^.Length) and (B^.lsData[W1] <= Blank) do
inc(W1);
if W1 <= B^.Length then begin
move(B^.lsData[W1], B^.lsData[1], B^.Length - W1 + 1);
B^.Length := B^.Length - W1 + 1;
end;
end; {lsTrimLead}
function lsTrimLeadF(A : LongString): LongString;
{-Return a LongString with leading white space removed}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(A^.Length);
lsTrimLead(A, ThisLs);
lsTrimLeadF := ThisLs;
end; {lsTrimLeadF}
procedure lsTrimTrail(A, B : LongString);
{-Return a LongString with trailing white space removed}
var
W1 : word;
begin
lsTransfer(A, B);
W1 := B^.Length;
while (W1 >= 1) and (B^.lsData[W1] <= Blank) do begin
dec(W1);
dec(B^.Length);
end;
end; {lsTrimTrail}
function lsTrimTrailF(A : LongString) : LongString;
{-Return a LongString with trailing white space removed}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(A^.Length);
lsTrimTrail(A, ThisLs);
lsTrimTrailF := ThisLs;
end; {lsTrimTrailF}
procedure lsTrim(A, B : LongString);
{-Return a LongString with leading and trailing white space removed}
var
ThisLs : LongString;
begin
if not lsInit(ThisLs, A^.Length) then exit;
lsTransfer(A, ThisLs);
lsTrimLead(lsTrimTrailF(ThisLs), B);
lsDispose(ThisLs);
end; {lsTrim}
function lsTrimF(A : LongString) : LongString;
{-Return a LongString with leading and trailing white space removed}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(A^.Length);
lsTrim(A, ThisLs);
lsTrimF := ThisLs;
end; {lsTrimF}
procedure lsCenterCh(A : LongString; Ch : Char; Width : word; B : LongString);
{-Return a LongString centered in a LongString of Ch with specified Width}
var
W1 : word;
begin
lsTransfer(A, B);
if Width > B^.dLength then exit;
if Width < B^.Length then begin
B^.Length := Width;
exit;
end;
W1 := Width - ((Width - B^.Length) shr 1);
lsLeftPadCh(B, Ch, W1, B);
lsPadCh(B, Ch, Width, B);
end; {lsCenterCh}
function lsCenterChF(A : LongString; Ch : Char; Width : word) : LongString;
{-Return a LongString centered in a LongString of Ch with specified width}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(Width);
lsCenterCh(A, Ch, Width, ThisLs);
lsCenterChF := ThisLs;
end; {lsCenterChF}
procedure lsCenter(A : LongString; Width : word; B : LongString);
{-Return a LongString centered in a LongString of blanks with specified width}
begin
lsCenterCh(A, Blank, Width, B);
end; {lsCenter}
function lsCenterF(A : LongString; Width : word) : LongString;
{-Return a LongString centered in a LongString of blanks with specified width}
var
ThisLs : LongString;
begin
ThisLs := NextInRing(Width);
lsCenterCh(A, Blank, Width, ThisLs);
lsCenterF := ThisLs;
end; {lsCenterF}
procedure lsIon;
{-Has the same effect with respect to lsReadLn, lsWriteLn as the $I+
compiler has with respect to normal I/O operations, except that
the reported error address is meaningless.}
begin
lsIoCheck := true;
end; {lsIon}
procedure lsIoff;
{-Has the same effect with respect to lsReadLn, lsWriteLn as the $I-
compiler has with respect to normal I/O operations, except that
the reported error address is meaningless.}
begin
lsIoCheck := false;
end; {lsIoff}
procedure SetIoRes;
begin
lsIoRes := IoResult;
if lsIoCheck and (lsIoRes <> 0) then
RunError(lsIoRes);
end; {SetIoRes}
procedure CheckIoRes;
begin
if (lsIoRes <> 0) then
RunError(lsIoRes);
end;
function lsIoResult : word;
{-Returns the value of IoResult resulting from the last lsReadLn or
lsWriteLn. NOTE: You MUST use lsIoResult for checking lsReadLn,
lsWriteLn. If you call IoResult instead, you will always get a 0
return.}
begin
lsIoResult := lsIoRes;
lsIoRes := 0;
end;
{$I-}
procedure lsReadLn(var F : text; A : LongString);
{-Reads a LongString from a text file. Returns the value of IoResult as
the function value.}
var
S : string;
W1 : word;
begin
CheckIoRes;
A^.Length := 0;
while (not eoln(F)) and (A^.dLength > A^.Length) do begin
Read(F, S);
SetIoRes;
if lsIoRes <> 0 then begin
exit;
end;
lsConcatStr2Ls(A, S, A);
end; {while}
ReadLn(F);
SetIoRes;
end; {lsReadLn}
procedure lsWriteLn(var F : text; A : LongString);
{-Writes a LongString to a text file. Returns the value of IoResult as
the function value.}
var
S : string;
W1,
W2,
Q,
R : word;
ThisLs : LongString;
begin
CheckIoRes;
if not lsInit(ThisLs, A^.Length) then exit;
lsTransfer(A, ThisLs);
Q := A^.Length div $FF;
R := A^.Length mod $FF;
for W1 := 1 to Q do begin
Write(F, lsLongString2Str(ThisLs));
SetIoRes;
Flush(F);
SetIoRes;
if lsIoRes <> 0 then begin
lsDispose(ThisLs);
exit;
end;
lsDelete(ThisLs, 1, $FF, ThisLs);
end; {for W1}
WriteLn(F, lsLongString2Str(ThisLs));
SetIoRes;
Flush(F);
SetIoRes;
lsDispose(ThisLs);
end; {lsWriteLn}
{$I+}
end.